home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1996 #14 / Monster Media No. 14 (April 1996) (Monster Media, Inc.).ISO / prog_bas / savbmp.zip / SAVBMP.BAS < prev    next >
BASIC Source File  |  1996-01-02  |  19KB  |  630 lines
  1. Option Explicit
  2. '***************************************************
  3. '
  4. '  This app demonstrates a method of saving bitmaps
  5. ' at any color depth.  Any bitmap may be loaded into
  6. ' the picturebox (any color depth: how it displays
  7. ' depends on your video driver, however).  You can
  8. ' then save it as a monochrome, 16-color, 256-color,
  9. ' or 16million color bitmap (with the corresponding
  10. ' differences in file size!).
  11. '  The file is saved as Test.bmp in the app directory.
  12. '
  13. '***************************************************
  14.  
  15. Type BITMAPFILEHEADER
  16.   bfType As Integer
  17.   bfsize As Long
  18.   bfReserved1 As Integer
  19.   bfReserved2 As Integer
  20.   bfOffBits As Long
  21. End Type
  22.  
  23. Type BITMAPINFOHEADER '40 bytes
  24.   biSize As Long
  25.   biWidth As Long
  26.   biHeight As Long
  27.   biPlanes As Integer
  28.   biBitCount As Integer
  29.   biCompression As Long
  30.   biSizeImage As Long
  31.   biXPelsPerMeter As Long
  32.   biYPelsPerMeter As Long
  33.   biClrUsed As Long
  34.   biClrImportant As Long
  35. End Type
  36.  
  37. Type LOGPALETTE16
  38.   PalVersion As Integer
  39.   PalNumEntries As Integer
  40.   palPalEntry(15) As Long
  41. End Type
  42.  
  43. Type LOGPALETTE256
  44.   PalVersion As Integer
  45.   PalNumEntries As Integer
  46.   palPalEntry As String * 1024
  47. End Type
  48.  
  49. Dim FileHead As BITMAPFILEHEADER
  50. Dim InfoHead As BITMAPINFOHEADER
  51. Dim Pal16 As LOGPALETTE16
  52. Dim Pal256 As LOGPALETTE256
  53.  
  54. Const HEADERLEN = 54
  55. Const BF_TYPE = 19778 ' "BM"
  56. Const PALLEN256 = 1024
  57. Const PALLEN16 = 64
  58. Const PALLEN2 = 8
  59. Const BISIZ = 40
  60.  
  61. Declare Function GetPixel Lib "GDI" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer) As Long
  62. Declare Function GetNearestPaletteIndex Lib "GDI" (ByVal hPalette As Integer, ByVal crColor As Long) As Integer
  63. Declare Function DeleteObject Lib "GDI" (ByVal hObject As Integer) As Integer
  64. 'alias two versions of CreatePalette for 16 or 256 colors
  65. Declare Function CreatePalette16 Lib "GDI" Alias "CreatePalette" (lpLogPalette As LOGPALETTE16) As Integer
  66. Declare Function CreatePalette256 Lib "GDI" Alias "CreatePalette" (lpLogPalette As LOGPALETTE256) As Integer
  67.  
  68. Function FileExist (Filenam As String) As Integer
  69.   ' checks whether a filespec exists
  70.   Dim Result As Integer
  71.   On Error GoTo FileExistErr
  72.   
  73.   Result = GetAttr(Filenam)
  74.   FileExist = True
  75.   Exit Function
  76.  
  77. FileExistErr:
  78. FileExist = False
  79. Exit Function
  80.  
  81. End Function
  82.  
  83. Function GreyScale (ByVal Colr As Long) As Integer
  84. ' Takes a long integer color value and converts it
  85. ' to an equivalent grayscale value between 0 and 255
  86.   Dim R As Long, G As Long, B As Long
  87.   
  88.   ' Break up long color value into red, green, blue
  89.   R = Colr Mod 256
  90.   Colr = Colr \ 256
  91.   G = Colr Mod 256
  92.   Colr = Colr \ 256
  93.   B = Colr Mod 256
  94.   
  95.   ' Find equivalent grayscale value, 0 - 255.
  96.   GreyScale = 76 * R / 255 + 150 * G / 255 + 28 * B / 255
  97.  
  98. End Function
  99.  
  100. Function InitPal16 () As Integer
  101.   Dim hPal As Variant  'I hate Variants, but CreatePalette() returns NULL if unsuccessful
  102.  
  103.   'initialize logical palette
  104.   Pal16.PalVersion = &H300
  105.   Pal16.PalNumEntries = 16
  106.   '16 standard Windows colors
  107.   Pal16.palPalEntry(0) = &H0&
  108.   Pal16.palPalEntry(1) = &HBF&
  109.   Pal16.palPalEntry(2) = &HBF00&
  110.   Pal16.palPalEntry(3) = &HBFBF&
  111.   Pal16.palPalEntry(4) = &HBF0000
  112.   Pal16.palPalEntry(5) = &HBF00BF
  113.   Pal16.palPalEntry(6) = &HBFBF00
  114.   Pal16.palPalEntry(7) = &H808080
  115.   Pal16.palPalEntry(8) = &HC0C0C0
  116.   Pal16.palPalEntry(9) = &HFF&
  117.   Pal16.palPalEntry(10) = &HFF00&
  118.   Pal16.palPalEntry(11) = &HFFFF&
  119.   Pal16.palPalEntry(12) = &HFF0000
  120.   Pal16.palPalEntry(13) = &HFF00FF
  121.   Pal16.palPalEntry(14) = &HFFFF00
  122.   Pal16.palPalEntry(15) = &HFFFFFF
  123.  
  124.   'create a logical palette
  125.   hPal = CreatePalette16(Pal16)
  126.  
  127.   'red is &HFF& in VB, and goes into the bmp palette as 4 bytes: FF 00 00 00
  128.   'because the *low* byte is written *first* to a binary file.  This would be
  129.   'great, except that the bmp file palette entries are arranged in byte order
  130.   'BB GG RR XX; *blue* is the first byte!
  131.   'Therefore, rearrange the palette for writing into the bitmap:
  132.   Pal16.palPalEntry(0) = &H0&
  133.   Pal16.palPalEntry(1) = &HBF0000  'dark blue in VB, but comes out dark red in bmp palette
  134.   Pal16.palPalEntry(2) = &HBF00&
  135.   Pal16.palPalEntry(3) = &HBFBF00
  136.   Pal16.palPalEntry(4) = &HBF&
  137.   Pal16.palPalEntry(5) = &HBF00BF
  138.   Pal16.palPalEntry(6) = &HBFBF&
  139.   Pal16.palPalEntry(7) = &H808080
  140.   Pal16.palPalEntry(8) = &HC0C0C0
  141.   Pal16.palPalEntry(9) = &HFF0000
  142.   Pal16.palPalEntry(10) = &HFF00&
  143.   Pal16.palPalEntry(11) = &HFFFF00
  144.   Pal16.palPalEntry(12) = &HFF&
  145.   Pal16.palPalEntry(13) = &HFF00FF
  146.   Pal16.palPalEntry(14) = &HFFFF&
  147.   Pal16.palPalEntry(15) = &HFFFFFF
  148.  
  149.   'return the palette handle, or -1 for an error
  150.   If IsNull(hPal) Then
  151.     InitPal16 = -1
  152.   Else
  153.     InitPal16 = hPal
  154.   End If
  155.   
  156. End Function
  157.  
  158. Function InitPal256 (Filenam As String) As Integer
  159.   Dim H As Integer, i As Integer
  160.   Dim FileHeader As BITMAPFILEHEADER
  161.   Dim InfoHeader As BITMAPINFOHEADER
  162.   Dim LogPal As LOGPALETTE256
  163.   Dim hPal As Variant
  164.   Dim tmp As String * 1
  165.   Dim chars As String * 4
  166.  
  167.   Pal256.PalVersion = &H300
  168.   Pal256.PalNumEntries = 256
  169.  
  170. ' Convert to grayscale:
  171.   If Form2!Check2 Then
  172.     For i = 1 To 1021 Step 4
  173.     ' this gives RGB = 0, 0, 0 to RGB = 255, 255, 255
  174.       chars = Chr$(i \ 4) & Chr$(i \ 4) & Chr$(i \ 4) & Chr$(0)
  175.       Mid$(LogPal.palPalEntry, i, 4) = chars
  176.       Mid$(Pal256.palPalEntry, i, 4) = chars
  177.     Next i
  178.     LogPal.PalVersion = &H300
  179.     LogPal.PalNumEntries = 256
  180.     hPal = CreatePalette256(LogPal)
  181.     GoTo CheckAndExit
  182.     'Exit Function
  183.   End If
  184.  
  185. ' it's too much typing to hard-code a default palette:
  186. ' we'll use the one from rainbow.dib
  187.   'FileNam = "c:\vb\rainbow.dib"
  188.   'The Filenam parameter above is a hook I never used:
  189.   ' instead we'll get the file name off Form2
  190.   Filenam = Form2!Text1
  191.   If Not FileExist(Filenam) Then
  192.     MsgBox "Palette file not found!"
  193.     GoTo CheckAndExit
  194.     'Exit Function
  195.   End If
  196.  
  197.   H = FreeFile
  198.   Open Filenam For Binary Access Read As #H
  199.   Get #H, , FileHeader
  200.   Get #H, , InfoHeader
  201.  
  202.   If FileHeader.bfType <> BF_TYPE Then
  203.     'not a bitmap
  204.     MsgBox "Palette file is Not a bitmap file." & FileHeader.bfType
  205.   ElseIf InfoHeader.biBitCount <> 8 Then
  206.     'not an 8-bit bitmap
  207.     MsgBox "Palette file is Not an 8-bit bitmap."
  208. '  ElseIf InfoHeader.biClrsUsed <> 0 and InfoHeader.biClrsUsed <> 256 then
  209. '    'palette may not contain 256 colors
  210.   ElseIf FileHeader.bfOffBits <> HEADERLEN + PALLEN256 Then
  211.     MsgBox "Palette contains only " & Str$((FileHeader.bfOffBits - HEADERLEN) / 4) & " Colors."
  212.   Else
  213.     'it's OK, do it
  214.  
  215.     'since we've defined the palette as a 1K string,
  216.     'we can read it in one gulp
  217.     Get #H, , Pal256.palPalEntry
  218.     'Now we've got to rearrange, since the palette just
  219.     ' read out of the bmp has BGR entries, but we need
  220.     ' RGB for the logical palette
  221.     For i = 1 To 1021 Step 4
  222.       Mid$(LogPal.palPalEntry, i, 1) = Mid$(Pal256.palPalEntry, i + 2, 1)
  223.       Mid$(LogPal.palPalEntry, i + 1, 1) = Mid$(Pal256.palPalEntry, i + 1, 1)
  224.       Mid$(LogPal.palPalEntry, i + 2, 1) = Mid$(Pal256.palPalEntry, i, 1)
  225.     Next i
  226.  
  227.     LogPal.PalVersion = &H300
  228.     LogPal.PalNumEntries = 256
  229.     
  230.   ' create the logical palette and retrieve its handle
  231.     hPal = CreatePalette256(LogPal)
  232.  
  233.   End If
  234.   Close #H
  235.  
  236. CheckAndExit:
  237. If IsNull(hPal) Or IsEmpty(hPal) Then
  238.   InitPal256 = -1
  239. Else
  240.   InitPal256 = hPal
  241. End If
  242.  
  243. End Function
  244.  
  245. Sub Output16Bmp (Filenam As String, Pict As Control)
  246. 'This routine reads a picturebox pixel by pixel and writes a
  247. '16-color bitmap to disk using the "nearest" standard color
  248.   Dim PixelsWide As Integer, PixelsHi As Integer
  249.   Dim OutH As Integer
  250.   Dim i As Integer, j As Integer, k As Integer
  251.   Dim Line16$
  252.   Dim Colr&
  253.   Dim hPal As Integer
  254.   Dim PicHDC As Integer
  255.   Dim PalNum As Integer
  256.  
  257. ' Set up the standard 16-color palette
  258.   hPal = InitPal16()
  259.   If hPal = -1 Then
  260.     MsgBox ("Problem creating palette!")
  261.     Exit Sub
  262.   End If
  263.   Screen.MousePointer = 11
  264.  
  265. ' The output bitmap is the same size as the picturebox:
  266. ' Picture1 has AutoSize = True and ScaleMode = 3 (pixel)
  267.   PixelsWide = Pict.ScaleWidth
  268.   PixelsHi = Pict.ScaleHeight
  269.  
  270. ' Open disk file for storing 16-color bmp:
  271.   OutH = FreeFile
  272.   Open Filenam For Binary Access Write As #OutH
  273.  
  274. ' set header data
  275.   InfoHead.biSize = BISIZ
  276.   InfoHead.biWidth = PixelsWide
  277.   InfoHead.biHeight = PixelsHi
  278.   InfoHead.biPlanes = 1
  279.   InfoHead.biBitCount = 4
  280.   InfoHead.biSizeImage = CLng(PixelsWide) * PixelsHi / 2
  281.   InfoHead.biClrImportant = 0
  282.  
  283.   FileHead.bfType = BF_TYPE
  284.   FileHead.bfOffBits = HEADERLEN + PALLEN16
  285.   FileHead.bfsize = FileHead.bfOffBits + WidthBytes(PixelsWide, InfoHead.biBitCount) * CLng(PixelsHi)
  286.  
  287.   Put #OutH, , FileHead
  288.   Put #OutH, , InfoHead
  289.  
  290. ' now write the 16-color palette to the file
  291.   For i = 0 To 15
  292.     Put #OutH, , Pal16.palPalEntry(i)
  293.   Next i
  294.  
  295. ' allocate string buffer to hold one line of 16-color bmp
  296.   Line16$ = Space(WidthBytes(PixelsWide, InfoHead.biBitCount))
  297.  
  298. ' get the picturebox hDC for GetPixel()
  299.   PicHDC = Pict.hDC
  300.  
  301. ' loop through all pixels in the image
  302.   For i = PixelsHi - 1 To 0 Step -1
  303.     'change picture to 16-color format:
  304.     'one byte of 16-color data = 2 pixels
  305.     For j = 0 To PixelsWide - 1 Step 2
  306.       'build up one byte (for two pixels of image)
  307.       'in the low byte of an integer:
  308.       PalNum = 0
  309.       For k = 0 To 1
  310.     'get color of this pixel from picturebox
  311.     'GetPixel is a little faster than Point
  312.     ''Colr& = Pict.Point(j + k, i)
  313.     Colr& = GetPixel(PicHDC, j + k, i)
  314.     'find nearest color in std windows palette
  315.     'and load into appropriate bits of integer PalNum.
  316.     'Exponentiation is slow, so I use the If/Else instead
  317.     ''PalNum = PalNum Or 16 ^ (1 - k) * GetNearestPaletteIndex(hPal, Colr&)
  318.     If k = 0 Then  'upper nibble
  319.       PalNum = PalNum Or 16 * GetNearestPaletteIndex(hPal, Colr&)
  320.     Else           'lower nibble
  321.       PalNum = PalNum Or GetNearestPaletteIndex(hPal, Colr&)
  322.     End If
  323.       Next k
  324.       ' add PalNum byte to character buffer
  325.       Mid$(Line16$, j / 2 + 1, 1) = Chr$(PalNum)
  326.     Next j
  327.  
  328.     'write out a line of the bmp
  329.     Put #OutH, , Line16$
  330.     DoEvents
  331.   Next i
  332.  
  333.   'All done: close the disk file
  334.   Close #OutH
  335.  
  336.   'release the palette
  337.   i = DeleteObject(hPal)
  338.   Screen.MousePointer = 0
  339.   If i = 0 Then MsgBox "Couldn't release palette!"
  340.  
  341. End Sub
  342.  
  343. Sub Output24BitBmp (Filenam As String, Pict As Control)
  344. 'This routine reads a picturebox pixel by pixel and writes a
  345. '16M-color bitmap to disk
  346.   Dim PixelsWide As Integer, PixelsHi As Integer
  347.   Dim OutH As Integer
  348.   Dim i As Integer, j As Integer
  349.   Dim Line16M$
  350.   Dim Colr&
  351.   Dim PicHDC As Integer
  352.   Dim Red%, Green%, Blue%
  353.  
  354.   Screen.MousePointer = 11
  355. '******************************
  356. 'Dim start
  357. 'start = Timer
  358. '******************************
  359.  
  360. ' The output bitmap is the same size as the picturebox:
  361. ' Picture1 has AutoSize = True and ScaleMode = 3 (pixel)
  362.   PixelsWide = Pict.ScaleWidth
  363.   PixelsHi = Pict.ScaleHeight
  364.  
  365. ' Open disk file for storing 16M-color bmp:
  366.   OutH = FreeFile
  367.   Open Filenam For Binary Access Write As #OutH
  368.  
  369. ' set header data
  370.   InfoHead.biSize = BISIZ
  371.   InfoHead.biWidth = PixelsWide
  372.   InfoHead.biHeight = PixelsHi
  373.   InfoHead.biPlanes = 1
  374.   InfoHead.biBitCount = 24
  375.   InfoHead.biSizeImage = CLng(PixelsWide) * PixelsHi * 3
  376.   InfoHead.biClrImportant = 0
  377.  
  378.   FileHead.bfType = BF_TYPE
  379.   FileHead.bfOffBits = HEADERLEN
  380.   FileHead.bfsize = FileHead.bfOffBits + WidthBytes(PixelsWide, InfoHead.biBitCount) * CLng(PixelsHi)
  381.  
  382.   Put #OutH, , FileHead
  383.   Put #OutH, , InfoHead
  384.  
  385. ' buffer to hold one line of 16M-color bmp
  386.   Line16M = Space(WidthBytes(PixelsWide, InfoHead.biBitCount))
  387.   
  388.   PicHDC = Pict.hDC
  389. ' loop through all pixels in the image
  390.   For i = PixelsHi - 1 To 0 Step -1
  391.     'change picture to 16M-color format:
  392.     'three bytes of 16M-color data = 1 pixel
  393.     For j = 0 To PixelsWide - 1 Step 1
  394.       'build up 3 bytes for one pixel of image
  395.       'get color of this pixel from picturebox
  396.       'GetPixel is a little faster than Point
  397.       'Colr& = Pict.Point(j, i)
  398.       Colr& = GetPixel(PicHDC, j, i)
  399.       'Break up long color value into RGB
  400.       Red% = Colr& Mod 256
  401.       Colr& = Colr& \ 256
  402.       Green% = Colr& Mod 256
  403.       Colr& = Colr& \ 256
  404.       Blue% = Colr& Mod 256
  405.       Mid$(Line16M$, j * 3 + 1, 1) = Chr$(Blue%)
  406.       Mid$(Line16M$, j * 3 + 2, 1) = Chr$(Green%)
  407.       Mid$(Line16M$, j * 3 + 3, 1) = Chr$(Red%)
  408.     Next j
  409.     'write out a line of the bmp
  410.     Put #OutH, , Line16M$
  411.   Next i
  412.   'All done: close the disk file
  413.   Close #OutH
  414.   Screen.MousePointer = 0
  415.  
  416. '*****************************
  417. 'Debug.Print Timer - start
  418. '*****************************
  419.  
  420. End Sub
  421.  
  422. Sub Output256Bmp (Filenam As String, Pict As Control)
  423. 'This routine reads a picturebox pixel by pixel and writes a
  424. '256-color bitmap to disk using the nearest available color
  425.   Dim PixelsWide As Integer, PixelsHi As Integer
  426.   Dim OutH As Integer
  427.   Dim i As Integer, j As Integer
  428.   Dim Line256$
  429.   Dim Colr&
  430.   Dim hPal As Integer
  431.   Dim PicHDC As Integer
  432.   Dim PalNum As Integer
  433.  
  434. '******************************
  435. 'Dim start
  436. 'start = Timer
  437. '******************************
  438. ' Set up the 256-color palette
  439.   hPal = InitPal256("dummy")
  440.   If hPal = -1 Then Exit Sub    'didn't work
  441.   
  442.   Screen.MousePointer = 11
  443.  
  444. ' The output bitmap is the same size as the picturebox:
  445. ' Picture1 has AutoSize = True and ScaleMode = 3 (pixel)
  446.   PixelsWide = Pict.ScaleWidth
  447.   PixelsHi = Pict.ScaleHeight
  448.  
  449. ' Open disk file for storing 256-color bmp:
  450.   OutH = FreeFile
  451.   Open Filenam For Binary Access Write As #OutH
  452.  
  453. ' set header data
  454.   InfoHead.biSize = BISIZ
  455.   InfoHead.biWidth = PixelsWide
  456.   InfoHead.biHeight = PixelsHi
  457.   InfoHead.biPlanes = 1
  458.   InfoHead.biBitCount = 8
  459.   InfoHead.biSizeImage = CLng(PixelsWide) * PixelsHi
  460.   InfoHead.biClrImportant = 0
  461.  
  462.   FileHead.bfType = BF_TYPE
  463.   FileHead.bfOffBits = HEADERLEN + PALLEN256
  464.   FileHead.bfsize = FileHead.bfOffBits + WidthBytes(PixelsWide, InfoHead.biBitCount) * CLng(PixelsHi)
  465.  
  466.   Put #OutH, , FileHead
  467.   Put #OutH, , InfoHead
  468.  
  469. ' now write the 256-color palette to the file
  470.   Put #OutH, , Pal256.palPalEntry
  471.  
  472. ' buffer to hold one line of 16-color bmp
  473.   Line256$ = Space(WidthBytes(PixelsWide, InfoHead.biBitCount))
  474.   
  475.   PicHDC = Pict.hDC
  476. ' loop through all pixels in the image
  477.   For i = PixelsHi - 1 To 0 Step -1
  478.     'change picture to 256-color format:
  479.     'one byte of 256-color data = 1 pixel
  480.     For j = 0 To PixelsWide - 1 Step 1
  481.       'build up one byte for one pixel of image
  482.       'in the low byte of an integer:
  483.       PalNum = 0
  484.       'get color of this pixel from picturebox
  485.       'GetPixel is a little faster than Point
  486.       'Colr& = Pict.Point(j, i)
  487.       Colr& = GetPixel(PicHDC, j, i)
  488.       'find nearest color in palette
  489.       PalNum = GetNearestPaletteIndex(hPal, Colr&)
  490.       ' add PalNum byte to PalNum line buffer
  491.       Mid$(Line256$, j + 1, 1) = Chr$(PalNum)
  492.     Next j
  493.     'write out a line of the bmp
  494.     Put #OutH, , Line256$
  495.     DoEvents
  496.   Next i
  497.   'All done: close the disk file
  498.   Close #OutH
  499.   'release the palette
  500.   i = DeleteObject(hPal)
  501.   Screen.MousePointer = 0
  502.   If i = 0 Then MsgBox "Couldn't release palette!"
  503.  
  504. '*****************************
  505. 'Debug.Print Timer - start
  506. '*****************************
  507.  
  508. End Sub
  509.  
  510. Sub OutputMonoBmp (Filenam As String, Pict As Control)
  511.  
  512. 'This routine reads a picturebox pixel by pixel and writes
  513. ' a monochrome bitmap to disk.
  514.   Dim AllToBlack As Integer, Threshold As Integer
  515.   Dim PixelsWide As Integer, PixelsHi As Integer
  516.   Dim OutH As Integer
  517.   Dim i As Integer, j As Integer, k As Integer
  518.   Dim LineMono$
  519.   Dim Colr&
  520.   Dim PicHDC As Integer
  521.   Dim mono As Integer
  522.   Dim BLACK As Long, WHITE As Long
  523.   BLACK = &H0&
  524.   WHITE = &HFFFFFF
  525.  
  526.   Screen.MousePointer = 11
  527. '******************************
  528. 'Dim start
  529. 'start = Timer
  530. '******************************
  531.   AllToBlack = Form2!Option1(0)
  532.   Threshold = Val(Form2!Label1)
  533.  
  534. ' The output bitmap is the same size as the picturebox:
  535. ' Picture1 has AutoSize = True and ScaleMode = 3 (pixel)
  536.   PixelsWide = Pict.ScaleWidth
  537.   PixelsHi = Pict.ScaleHeight
  538.  
  539. ' Open disk file for storing monochrome bmp:
  540.   OutH = FreeFile
  541.   Open Filenam For Binary Access Write As #OutH
  542.  
  543. ' header info
  544.   InfoHead.biSize = BISIZ
  545.   InfoHead.biWidth = PixelsWide
  546.   InfoHead.biHeight = PixelsHi
  547.   InfoHead.biPlanes = 1
  548.   InfoHead.biBitCount = 1
  549.   InfoHead.biSizeImage = CLng(PixelsWide) * PixelsHi / 8
  550.   InfoHead.biClrImportant = 0
  551.  
  552.   FileHead.bfType = BF_TYPE
  553.   FileHead.bfOffBits = HEADERLEN + PALLEN2
  554.   FileHead.bfsize = FileHead.bfOffBits + WidthBytes(PixelsWide, InfoHead.biBitCount) * CLng(PixelsHi)
  555.  
  556.   Put #OutH, , FileHead
  557.   Put #OutH, , InfoHead
  558.  
  559. ' palette (black and white)
  560.   If Form2!Check1 Then
  561.   ' negative image
  562.     Put #OutH, , WHITE
  563.     Put #OutH, , BLACK
  564.   Else
  565.     Put #OutH, , BLACK
  566.     Put #OutH, , WHITE
  567.   End If
  568.  
  569. ' buffer to hold one line of mono bmp
  570.   LineMono$ = Space(WidthBytes(PixelsWide, InfoHead.biBitCount))
  571.   PicHDC = Pict.hDC
  572. ' loop through all pixels in the image
  573.   For i = PixelsHi - 1 To 0 Step -1
  574.     'change picture to mono format:
  575.     ''one byte of mono data = 8 pixels
  576.     For j = 0 To PixelsWide - 1 Step 8
  577.       ' build up mono byte (for eight pixels of image)
  578.       ' in the low byte of an integer:
  579.       mono = 0
  580.       For k = 0 To 7
  581.     'get color of this pixel from picturebox
  582.     'GetPixel is a little faster than Point
  583.     'Colr& = Pict.Point(j + k, i)
  584.     Colr& = GetPixel(PicHDC, j + k, i)
  585.     If AllToBlack Then
  586.       ' white is the background color: anything else is black.
  587.       'if it's white, set that bit.  Otherwise, just go on to next
  588.       'Note: exponentiation is *slow*: select case would be faster
  589.       If Colr& = WHITE Then mono = mono Or 2 ^ (7 - k)
  590.     Else
  591.       ' any color lighter than the threshold goes white:
  592.       If GreyScale(Colr&) >= Threshold Then mono = mono Or 2 ^ (7 - k)
  593.     End If
  594.       Next k
  595.       ' add mono byte to mono line buffer
  596.       Mid$(LineMono$, j / 8 + 1, 1) = Chr$(mono)
  597.     Next j
  598.     'write out a line of mono bmp
  599.     Put #OutH, , LineMono$
  600.     DoEvents
  601.   Next i
  602.   'All done: close the disk file
  603.   Close #OutH
  604.   Screen.MousePointer = 0
  605. '*****************************
  606. 'Debug.Print Timer - start
  607. '*****************************
  608.  
  609. End Sub
  610.  
  611. Function WidthBytes (Wide As Integer, BitCount As Integer) As Integer
  612. ' all bmps must have a multiple of 32 bits (a long integer)
  613. ' in each row even if not all the bits are used
  614.   Dim tmp!
  615.   Dim i%
  616.  
  617.   tmp! = Wide * BitCount / 32
  618.   i% = Int(tmp!)
  619.   If i% <> tmp! Then i% = i% + 1
  620.   WidthBytes = i% * 4
  621.  
  622. End Function
  623.  
  624. Function WidthBytes2 (Wide As Integer, BitCount As Integer) As Integer
  625. ' this is a neat algorithm I stole from VB4 How-To.
  626. ' I'm not sure I get it, but it *does* work!
  627.   WidthBytes2 = ((CLng(BitCount) * CLng(Wide) + 31&) And &HFFE0) \ 8
  628. End Function
  629.  
  630.